COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	 The Simple Pattern Matcher
C00006 ENDMK
C⊗;
;;; The Simple Pattern Matcher
(declare (fasload struct fas dsk (mac lsp)))
;;; Choice Macros

(DECLARE (SETQ DEFMACRO-FOR-COMPILING ()) 
	 (MAPEX T))

(EVAL-WHEN (COMPILE EVAL)
	   (DEFSTRUCT CHOOSER 
		      PAST-CHOICES ORIGINAL-DATA VARIABLE PREDICATES CHOICE EMPTY
		      CONSTANTP))

(DEFMACRO CHOOSEP (X) `(AND (NOT (ATOM ,X))
			    (MEMQ (CAR ,X) '($CHOOSE $CH))))

(DEFMACRO CHOOSE-VAR (X) `(CADR ,X))

(DEFMACRO EMPTY-CHOICE (X) `(NULL ,X))

(DEFMACRO COPY (X) `(MAPCAR (FUNCTION (LAMBDA (X) X)) ,X)))

(DEFUN %%CHOOSE-FIRST (P D)
       (%%CHOOSER
	(MAKE-CHOOSER PAST-CHOICES () ORIGINAL-DATA D
		      CONSTANTP (ATOM P)
		      CHOICE ()
		      EMPTY ()
		      VARIABLE (COND ((ATOM P) P)
				     (T (CADR P)))
		      PREDICATES (COND ((ATOM P) ())
				       (T (CDDR P))))))

(DEFUN %%CHOOSE-NEXT (OLD-CHOOSER)
       (%%CHOOSER
	(MAKE-CHOOSER
	 PAST-CHOICES (PAST-CHOICES OLD-CHOOSER) 
	 ORIGINAL-DATA (ORIGINAL-DATA OLD-CHOOSER)
	 CONSTANTP (CONSTANTP OLD-CHOOSER)
	 CHOICE ()
	 EMPTY ()
	 VARIABLE (VARIABLE OLD-CHOOSER)
	 PREDICATES (PREDICATES OLD-CHOOSER))))

(DEFMACRO NEXT-CHOICE (X) `(CHOICE ,X))

(DEFUN %%CHOOSER (CHOOSER)
 (LET ((P (VARIABLE CHOOSER))
       (D (COPY (ORIGINAL-DATA CHOOSER))))
      (LET ((CH ()))
	   (COND ((CONSTANTP CHOOSER)
		  (COND ((MEMQ P D)
			 (SETQ CH `(,P . ,(DELETE P D))) 
			 (COND ((MEMBER CH (PAST-CHOICES CHOOSER))
				(SETF (EMPTY CHOOSER) T))
			       (T (SETF (CHOICE CHOOSER) CH)
				  (SETF (PAST-CHOICES CHOOSER)
					`(,CH . ,(PAST-CHOICES CHOOSER))))))
			(T (SETF (EMPTY CHOOSER) T))))
		 (T (LET ((CAND (%%SEARCH (PREDICATES CHOOSER) D)))
			 (COND (CAND
				(SETQ CH `(,(CAR CAND) 
					   . ,(DELETE (CAR CAND)
						      D)))
				(COND ((MEMBER CH (PAST-CHOICES CHOOSER))
				       (SETF (EMPTY CHOOSER) T)) 
				      (T (SETF (CHOICE CHOOSER) CH)
					 (SETF (PAST-CHOICES CHOOSER)
					       `(,CH . ,(PAST-CHOICES CHOOSER))))))
				     (T (SETF (EMPTY CHOOSER) T))))))))  
 CHOOSER) 

(DEFUN %%SEARCH (PREDS L)
       (DO ((L L (CDR L)))
	   ((NULL L) ())
	   (COND ((APPLY 'AND
			 (MAPCAR (FUNCTION (LAMBDA (F)
						   (FUNCALL F (CAR L))))
				 PREDS))
		  (RETURN `(,(CAR L)))))))